home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / vm.lisp < prev   
Encoding:
Text File  |  1991-11-09  |  11.3 KB  |  399 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: vm.lisp,v 1.44 91/11/09 02:37:48 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: vm.lisp,v 1.44 91/11/09 02:37:48 wlott Exp $
  15. ;;;
  16. ;;; This file contains the VM definition for the MIPS R2000 and the new
  17. ;;; object format.
  18. ;;;
  19. ;;; Written by Christopher Hoover and William Lott.
  20. ;;;
  21. (in-package "MIPS")
  22.  
  23.  
  24. ;;;; Registers
  25.  
  26. (eval-when (compile eval)
  27.  
  28. (defmacro defreg (name offset)
  29.   (let ((offset-sym (symbolicate name "-OFFSET")))
  30.     `(progn
  31.        (eval-when (compile eval load)
  32.      (defconstant ,offset-sym ,offset))
  33.        (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
  34.  
  35. (defmacro defregset (name &rest regs)
  36.   `(eval-when (compile eval load)
  37.      (defconstant ,name
  38.        (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs)))))
  39.  
  40. )
  41.  
  42. (defvar *register-names* (make-array 32 :initial-element nil))
  43.  
  44. (defreg zero 0)
  45. (defreg nl3 1)
  46. (defreg nl4 2)
  47. (defreg flags 3)
  48. (defreg nl0 4) ; First C argument reg.
  49. (defreg nl1 5)
  50. (defreg nl2 6)
  51. (defreg nargs 7)
  52. (defreg a0 8)
  53. (defreg a1 9)
  54. (defreg a2 10)
  55. (defreg a3 11)
  56. (defreg a4 12)
  57. (defreg a5 13)
  58. (defreg cname 14)
  59. (defreg lexenv 15)
  60. (defreg nfp 16)
  61. (defreg ocfp 17)
  62. (eval-when (compile load eval)
  63.   (defconstant old-fp-offset 17)) ; for backwards compatibility
  64. (defreg lra 18)
  65. (defreg l0 19)
  66. (defreg null 20)
  67. (defreg bsp 21)
  68. (defreg cfp 22)
  69. (eval-when (compile load eval)
  70.   (defconstant fp-offset 22)) ; for backwards compatibility
  71. (defreg csp 23)
  72. (defreg l1 24)
  73. (defreg alloc 25)
  74. (defreg l2 28)
  75. (defreg nsp 29)
  76. (defreg code 30)
  77. (defreg lip 31)
  78.  
  79. (defregset non-descriptor-regs
  80.   nl0 nl1 nl2 nl3 nl4 nargs)
  81.  
  82. (defregset descriptor-regs
  83.   a0 a1 a2 a3 a4 a5 cname lexenv nfp ocfp lra l0 l1 l2)
  84.  
  85. (defregset register-arg-offsets
  86.   a0 a1 a2 a3 a4 a5)
  87.  
  88. (defregset reserve-descriptor-regs
  89.   cname lexenv)
  90.  
  91. (defregset reserve-non-descriptor-regs
  92.   nl3 nl4)
  93.  
  94.  
  95. ;;;; SB and SC definition:
  96.  
  97. (define-storage-base registers :finite :size 32)
  98. (define-storage-base float-registers :finite :size 32)
  99. (define-storage-base control-stack :unbounded :size 8)
  100. (define-storage-base non-descriptor-stack :unbounded :size 0)
  101. (define-storage-base constant :non-packed)
  102. (define-storage-base immediate-constant :non-packed)
  103.  
  104. ;;;
  105. ;;; Handy macro so we don't have to keep changing all the numbers whenever
  106. ;;; we insert a new storage class.
  107. ;;; 
  108. (defmacro define-storage-classes (&rest classes)
  109.   (do ((forms (list 'progn)
  110.           (let* ((class (car classes))
  111.              (sc-name (car class))
  112.              (constant-name (intern (concatenate 'simple-string
  113.                              (string sc-name)
  114.                              "-SC-NUMBER"))))
  115.         (list* `(define-storage-class ,sc-name ,index
  116.               ,@(cdr class))
  117.                `(defconstant ,constant-name ,index)
  118.                `(export ',constant-name)
  119.                forms)))
  120.        (index 0 (1+ index))
  121.        (classes classes (cdr classes)))
  122.       ((null classes)
  123.        (nreverse forms))))
  124.  
  125. (define-storage-classes
  126.  
  127.   ;; Non-immediate contstants in the constant pool
  128.   (constant constant)
  129.  
  130.  
  131.   ;; Immediate numeric constants.
  132.   ;; 
  133.   ;;   zero = (integer 0 0)
  134.   ;; 
  135.   ;;   negative-immediate = (integer #x-1FFF #-x0001)
  136.   ;;        The funny lower bound guarantees that the negation of an immediate
  137.   ;;        is still an immediate.
  138.   ;; 
  139.   ;;   immediate = (integer 0 #x1FFE)
  140.   ;;       The funny upper bound guarantees that (1+ immediate) will fit in
  141.   ;;        16 bits.
  142.   ;; 
  143.   ;;   unsigned-immediate = (integer #x1FFF #x3FFE)
  144.   ;;       The funny upper bound guarantees that (1+ immediate) will fit in
  145.   ;;        16 bits.
  146.   ;;
  147.   (zero immediate-constant)
  148.   (negative-immediate immediate-constant)
  149.   (immediate immediate-constant)
  150.   (unsigned-immediate immediate-constant)
  151.  
  152.   ;; Immediate SCs for things other than numbers. 
  153.   (null immediate-constant)
  154.   (immediate-base-char immediate-constant)
  155.   (immediate-sap immediate-constant)
  156.  
  157.   ;; Anything else that can be computed faster than loaded that doesn't fit in
  158.   ;; any of the above immediate SCs.
  159.   (random-immediate immediate-constant)
  160.  
  161.  
  162.  
  163.   ;; **** The stacks.
  164.  
  165.   ;; The control stack.  (Scanned by GC)
  166.   (control-stack control-stack)
  167.  
  168.   ;; The non-descriptor stacks.
  169.   (signed-stack non-descriptor-stack) ; (signed-byte 32)
  170.   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
  171.   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
  172.   (sap-stack non-descriptor-stack) ; System area pointers.
  173.   (single-stack non-descriptor-stack) ; single-floats
  174.   (double-stack non-descriptor-stack :element-size 2) ; double floats.
  175.  
  176.  
  177.  
  178.   ;; **** Things that can go in the integer registers.
  179.  
  180.   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
  181.   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
  182.   (any-reg
  183.    registers
  184.    :locations #.(append non-descriptor-regs descriptor-regs)
  185.    :reserve-locations #.(append reserve-non-descriptor-regs
  186.                 reserve-descriptor-regs)
  187.    :constant-scs (negative-immediate zero immediate unsigned-immediate
  188.                immediate-base-char random-immediate)
  189.    :save-p t
  190.    :alternate-scs (control-stack))
  191.  
  192.   ;; Pointer descriptor objects.  Must be seen by GC.
  193.   (descriptor-reg registers
  194.    :locations #.descriptor-regs
  195.    :reserve-locations #.reserve-descriptor-regs
  196.    :constant-scs (constant null random-immediate)
  197.    :save-p t
  198.    :alternate-scs (control-stack))
  199.  
  200.   ;; Non-Descriptor characters
  201.   (base-char-reg registers
  202.    :locations #.non-descriptor-regs
  203.    :reserve-locations #.reserve-non-descriptor-regs
  204.    :constant-scs (immediate-base-char)
  205.    :save-p t
  206.    :alternate-scs (base-char-stack))
  207.  
  208.   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
  209.   (sap-reg registers
  210.    :locations #.non-descriptor-regs
  211.    :reserve-locations #.reserve-non-descriptor-regs
  212.    :constant-scs (immediate-sap)
  213.    :save-p t
  214.    :alternate-scs (sap-stack))
  215.  
  216.   ;; Non-Descriptor (signed or unsigned) numbers.
  217.   (signed-reg registers
  218.    :locations #.non-descriptor-regs
  219.    :reserve-locations #.reserve-non-descriptor-regs
  220.    :constant-scs (negative-immediate zero immediate unsigned-immediate
  221.                      random-immediate)
  222.    :save-p t
  223.    :alternate-scs (signed-stack))
  224.   (unsigned-reg registers
  225.    :locations #.non-descriptor-regs
  226.    :reserve-locations #.reserve-non-descriptor-regs
  227.    :constant-scs (zero immediate unsigned-immediate random-immediate)
  228.    :save-p t
  229.    :alternate-scs (unsigned-stack))
  230.  
  231.   ;; Random objects that must not be seen by GC.  Used only as temporaries.
  232.   (non-descriptor-reg registers
  233.    :locations #.non-descriptor-regs)
  234.  
  235.   ;; Pointers to the interior of objects.  Used only as an temporary.
  236.   (interior-reg registers
  237.    :locations (#.lip-offset))
  238.  
  239.  
  240.   ;; **** Things that can go in the floating point registers.
  241.  
  242.   ;; Non-Descriptor single-floats.
  243.   (single-reg float-registers
  244.    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  245.    :reserve-locations (26 28 30)
  246.    :constant-scs ()
  247.    :save-p t
  248.    :alternate-scs (single-stack))
  249.  
  250.   ;; Non-Descriptor double-floats.
  251.   (double-reg float-registers
  252.    :locations (0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30)
  253.    :reserve-locations (26 28 30)
  254.    ;; Note: we don't bother with the element size, 'cause nothing can be
  255.    ;; allocated in the odd fp regs anyway.
  256.    :constant-scs ()
  257.    :save-p t
  258.    :alternate-scs (double-stack))
  259.  
  260.   ;; A catch or unwind block.
  261.   (catch-block control-stack :element-size vm:catch-block-size))
  262.  
  263.  
  264.  
  265.  
  266. ;;;; Random TNs for interesting registers
  267.  
  268. (eval-when (compile eval)
  269.  
  270. (defmacro defregtn (name sc)
  271.   (let ((offset-sym (symbolicate name "-OFFSET"))
  272.     (tn-sym (symbolicate name "-TN")))
  273.     `(defparameter ,tn-sym
  274.        (make-random-tn :kind :normal
  275.                :sc (sc-or-lose ',sc)
  276.                :offset ,offset-sym))))
  277.  
  278. )
  279.  
  280. (defregtn zero any-reg)
  281. (defregtn lip interior-reg)
  282. (defregtn code descriptor-reg)
  283. (defregtn flags non-descriptor-reg)
  284. (defregtn alloc any-reg)
  285. (defregtn null descriptor-reg)
  286.  
  287. (defregtn nargs any-reg)
  288. (defregtn cname descriptor-reg)
  289. (defregtn lexenv descriptor-reg)
  290.  
  291. (defregtn bsp any-reg)
  292. (defregtn csp any-reg)
  293. (defregtn cfp any-reg)
  294. (defregtn ocfp any-reg)
  295. (defregtn fp any-reg) ; for backwards compatibility
  296. (defregtn old-fp any-reg) ; for backwards compatibility
  297. (defregtn nsp any-reg)
  298. (defregtn nfp any-reg)
  299.  
  300.  
  301.  
  302. ;;;
  303. ;;; Immediate-Constant-SC  --  Interface
  304. ;;;
  305. ;;; If value can be represented as an immediate constant, then return the
  306. ;;; appropriate SC number, otherwise return NIL.
  307. ;;;
  308. (def-vm-support-routine immediate-constant-sc (value)
  309.   (typecase value
  310.     ((integer 0 0)
  311.      (sc-number-or-lose 'zero *backend*))
  312.     (null
  313.      (sc-number-or-lose 'null *backend*))
  314.     ((integer #x-1FFF #x-0001)
  315.      (sc-number-or-lose 'negative-immediate *backend*))
  316.     ((integer 0 #x1FFE)
  317.      (sc-number-or-lose 'immediate *backend*))
  318.     ((integer #x1FFF #x3FFE)
  319.      (sc-number-or-lose 'unsigned-immediate *backend*))
  320.     (symbol
  321.      (if (vm:static-symbol-p value)
  322.      (sc-number-or-lose 'random-immediate *backend*)
  323.      nil))
  324.     (#-new-compiler (signed-byte 30)
  325.      #+new-compiler fixnum
  326.      (sc-number-or-lose 'random-immediate *backend*))
  327.     #+new-compiler
  328.     (system-area-pointer
  329.      (sc-number-or-lose 'immediate-sap *backend*))
  330.     (character
  331.      #-new-compiler
  332.      (if (string-char-p value)
  333.      (sc-number-or-lose 'immediate-base-char *backend*)
  334.      nil)
  335.      #+new-compiler
  336.      (sc-number-or-lose 'immediate-base-char *backend*))))
  337.  
  338.  
  339. ;;;; Function Call Parameters
  340.  
  341. ;;; The SC numbers for register and stack arguments/return values.
  342. ;;;
  343. (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
  344. (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
  345. (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
  346.  
  347. (eval-when (compile load eval)
  348.  
  349. ;;; Offsets of special stack frame locations
  350. (defconstant ocfp-save-offset 0)
  351. (defconstant old-fp-save-offset 0) ; for backwards compatablility.
  352. (defconstant lra-save-offset 1)
  353. (defconstant nfp-save-offset 2)
  354.  
  355.  
  356. ;;; The number of arguments/return values passed in registers.
  357. ;;;
  358. (defconstant register-arg-count 6)
  359.  
  360. ;;; The offsets within the register-arg SC that we pass values in, first
  361. ;;; value first.
  362. ;;;
  363.  
  364. ;;; Names to use for the argument registers.
  365. ;;; 
  366. (defconstant register-arg-names '(a0 a1 a2 a3 a4 a5))
  367.  
  368. ); Eval-When (Compile Load Eval)
  369.  
  370.  
  371. ;;; A list of TN's describing the register arguments.
  372. ;;;
  373. (defparameter register-arg-tns
  374.   (mapcar #'(lambda (n)
  375.           (make-random-tn :kind :normal
  376.                   :sc (sc-or-lose 'descriptor-reg)
  377.                   :offset n))
  378.       register-arg-offsets))
  379.  
  380.  
  381.  
  382. ;;; LOCATION-PRINT-NAME  --  Interface
  383. ;;;
  384. ;;;    This function is called by debug output routines that want a pretty name
  385. ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
  386. ;;;
  387. (def-vm-support-routine location-print-name (tn)
  388.   (declare (type tn tn))
  389.   (let ((sb (sb-name (sc-sb (tn-sc tn))))
  390.     (offset (tn-offset tn)))
  391.     (ecase sb
  392.       (registers (or (svref *register-names* offset)
  393.              (format nil "R~D" offset)))
  394.       (float-registers (format nil "F~D" offset))
  395.       (control-stack (format nil "CS~D" offset))
  396.       (non-descriptor-stack (format nil "NS~D" offset))
  397.       (constant (format nil "Const~D" offset))
  398.       (immediate-constant "Immed"))))
  399.